home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / scsh-condition.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  91 lines
  1. ;;; Copyright (c) 1994 by Olin Shivers
  2. ;;; Add scsh conditions to s48.
  3.  
  4. ;;; A syscall-error condition-type:
  5.  
  6. (define-condition-type 'syscall-error '(error))
  7.  
  8. (define syscall-error? (condition-predicate 'syscall-error))
  9.  
  10. (define (errno-error errno syscall . stuff)
  11.   (let ((msg (errno-msg errno)))
  12.     (apply signal 'syscall-error errno msg syscall stuff)))
  13.  
  14.  
  15. (define (with-errno-handler* handler thunk)
  16.   (with-handler
  17.     (lambda (condition more)
  18.       (if (syscall-error? condition)
  19.       (let ((stuff (condition-stuff condition)))
  20.         (handler (car stuff)    ; errno
  21.              (cdr stuff))))    ; (msg syscall . packet)
  22.       (more))
  23.     thunk))
  24.  
  25. ;;; (with-errno-handler
  26. ;;;   ((errno data) ; These are vars bound in this scope.
  27. ;;;    ((errno/exist) . body1)
  28. ;;;    ((errno/wouldblock errno/again) . body2)
  29. ;;;    (else . body3))
  30. ;;; 
  31. ;;;   . body)
  32.  
  33. (define-syntax with-errno-handler
  34.   (lambda (exp rename compare)
  35.     (let* ((%lambda (rename 'lambda))
  36.        (%cond (rename 'cond))
  37.        (%else (rename 'else))
  38.        (%weh (rename 'with-errno-handler*))
  39.        (%= (rename '=))         
  40.        (%begin (rename `begin))
  41.        (%or (rename `or))
  42.        (%call/cc (rename 'call-with-current-continuation))
  43.        (%cwv (rename 'call-with-values))
  44.  
  45.        (%ret (rename 'ret)) ; I think this is the way to gensym.
  46.  
  47.        (err-var (caaadr exp))
  48.        (data-var (car (cdaadr exp)))
  49.        (clauses (cdadr exp))
  50.        (body (cddr exp))
  51.  
  52.        (arms (map (lambda (clause)
  53.             (let ((test (if (compare (car clause) %else)
  54.                     %else
  55.                     (let ((errs (car clause)))
  56.                       `(,%or . ,(map (lambda (err)
  57.                                `(,%= ,err ,err-var))
  58.                              errs))))))
  59.               `(,test
  60.                 (,%cwv (,%lambda () . ,(cdr clause)) ,%ret))))
  61.               clauses)))
  62.  
  63.       `(,%call/cc (,%lambda (,%ret)
  64.          (,%weh
  65.         (,%lambda (,err-var ,data-var)
  66.           (,%cond . ,arms))
  67.         (,%lambda () . ,body)))))))
  68.  
  69. ;;;; S48 already has this machinery, i.e., (SET-INTERACTIVE?! flag)
  70. ;;;; Interactive => breakpoint on errors.
  71. ;;;; Noninteractive => exit on errors.
  72. ;
  73. ;(define $interactive-errors? (make-fluid #f))
  74. ;
  75. ;(define (with-interactive-errors val thunk)
  76. ;  (let-fluid $interactive-errors? val thunk))
  77. ;
  78. ;(define (set-interactive-errors! val)
  79. ;  (set-fluid! $interactive-errors? val))
  80. ;
  81. ;;;; Just quit if non-interactive. Otherwise, punt to next handler.
  82. ;;;; A hack, because we use the default handler for the interactive
  83. ;;;; case.
  84. ;
  85. ;(define (scsh-error-handler condition more)
  86. ;  (if (and (error? condition)
  87. ;       (not (fluid $interactive-errors?)))
  88. ;      (begin (display condition (error-output-port))
  89. ;         (exit -1))
  90. ;      (more)))
  91.